VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Public Font As StdFont
Public ForeColor As Long
Public ItemHeight As Long

Private bmpData As New cAlphaDibSection
Private bmpIml As New cAlphaDibSection
Private Imlw As Long, Imlh As Long

Private r As RECT, h As Long

Private Type typeItem
 Key As String
 Text As String
 i As Long
 clr As Long
 en As Boolean
 x As Long
End Type
Private itms() As typeItem
Private itmc As Long
Private itmn As Long

Private Scrl As Boolean, en As Boolean
Private sy As Long, lC As Long, sm As Long 'lc=Large change;sm=Max
Private ly As Long, lh As Long  'ly=Scroll y;lh=Scroll height

Private mx As Long, my As Long, mz As Long 'mz=Pushed no.
Private oy As Long 'old mouse y

Private Sub Class_Initialize()
en = True
bmpData.CreateFromPicture frmMain.Image1(IIf(Debug1, 4, 0)).Picture
End Sub

Public Sub Redraw()
On Error Resume Next
Dim i As Long, b As Long
Dim q As RECT
If itmc = 0 Then Exit Sub 'ERRR!!
For i = 0 To (r.Bottom - r.Top) \ ItemHeight
 If i + sy > itmc Then Exit For
 With itms(i + sy)
  b = IIf(i + sy = itmn, ForeColor, .clr)
  If .i > 0 Then
   TransBltA h, r.Left + .x, r.Top + i * ItemHeight + (ItemHeight - Imlh) \ 2, Imlw, Imlh, _
   bmpIml.hdc, (.i - 1) * Imlw, 0, Imlw, Imlh, vbMagenta
   DrawTextB h, .Text, Font, r.Left + .x + Imlw, r.Top + i * ItemHeight, r.Right - r.Left, ItemHeight, DT_VCENTER Or DT_SINGLELINE Or DT_EXPANDTABS, b, , True
  Else
   DrawTextB h, .Text, Font, r.Left + .x, r.Top + i * ItemHeight, r.Right - r.Left, ItemHeight, DT_VCENTER Or DT_SINGLELINE Or DT_EXPANDTABS, b, , True
  End If
  If i + sy = itmn Then
   q.Left = r.Left + .x
   q.Top = r.Top + i * ItemHeight
   q.Right = r.Right
   q.Bottom = r.Top + (i + 1) * ItemHeight
   DrawFocusRect h, q
  End If
 End With
Next i
If Scrl Then 'scroll bar
 If mz = 1 Then 'push
  bmpData.PaintPicture h, r.Right - 17, r.Top, 17, 17, 0, 34
 ElseIf mx > r.Right - 17 And mx < r.Right And my > r.Top And my < r.Top + 17 Then 'on
  bmpData.PaintPicture h, r.Right - 17, r.Top, 17, 17, 0, 17
 Else
  bmpData.PaintPicture h, r.Right - 17, r.Top, 17, 17, 0, 0
 End If
 If mz = 2 Then
  StretchBlt h, r.Right - 17, r.Top + 17, 17, ly - 17, bmpData.hdc, 32, 17, 17, 17, vbSrcCopy
 Else
  StretchBlt h, r.Right - 17, r.Top + 17, 17, ly - 17, bmpData.hdc, 32, 0, 17, 17, vbSrcCopy
 End If
 If mz = 3 Then 'push
  DrawBon r.Right - 17, r.Top + ly, lh, 2
 ElseIf mx > r.Right - 17 And mx < r.Right And my > r.Top + ly And my < r.Top + ly + lh Then 'on
  DrawBon r.Right - 17, r.Top + ly, lh, 1
 Else
  DrawBon r.Right - 17, r.Top + ly, lh, 0
 End If
 If mz = 4 Then
  StretchBlt h, r.Right - 17, r.Top + ly + lh, 17, r.Bottom - r.Top - ly - lh - 17, bmpData.hdc, 32, 17, 17, 17, vbSrcCopy
 Else
  StretchBlt h, r.Right - 17, r.Top + ly + lh, 17, r.Bottom - r.Top - ly - lh - 17, bmpData.hdc, 32, 0, 17, 17, vbSrcCopy
 End If
 If mz = 5 Then 'push
  bmpData.PaintPicture h, r.Right - 17, r.Bottom - 17, 17, 17, 0, 85
 ElseIf mx > r.Right - 17 And mx < r.Right And my > r.Bottom - 17 And my < r.Bottom Then 'on
  bmpData.PaintPicture h, r.Right - 17, r.Bottom - 17, 17, 17, 0, 68
 Else
  bmpData.PaintPicture h, r.Right - 17, r.Bottom - 17, 17, 17, 0, 51
 End If
 'key down
 If GetAsyncKeyState(vbKeyPageUp) = &H8001 Then
  sy = sy - lC
  If sy < 1 Then sy = 1
  CalcL
 ElseIf GetAsyncKeyState(vbKeyPageDown) = &H8001 Then
  sy = sy + lC
  If sy > sm Then sy = sm
  CalcL
 ElseIf GetAsyncKeyState(vbKeyHome) < 0 Then
  sy = 1
  CalcL
 ElseIf GetAsyncKeyState(vbKeyEnd) < 0 Then
  sy = sm
  CalcL
 End If
End If
If GetAsyncKeyState(vbKeyUp) = &H8001 Then
 PPA
ElseIf GetAsyncKeyState(vbKeyDown) = &H8001 Then
 PCB
End If
End Sub

Private Sub PPA()
Dim i As Long
For i = itmn - 1 To 1 Step -1
 If itms(i).en Then
  ListIndex = i - 1
  Exit Sub
 End If
Next i
ListIndex = IIf(itmn = 0, 0, itmn - 1)
End Sub

Private Sub PCB()
Dim i As Long
For i = itmn + 1 To itmc
 If itms(i).en Then
  ListIndex = i - 1
  Exit Sub
 End If
Next i
ListIndex = itmn - 1
End Sub

Private Sub pDelta(ByVal n As Long)
Dim i As Long
If n > 0 Then
 For i = 1 To n
  PCB
 Next i
ElseIf n < 0 Then
 For i = 1 To -n
  PPA
 Next i
End If
End Sub

Public Sub Create(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal w As Long, ByVal hi As Long)
h = hdc
r.Left = x
r.Top = y
r.Right = x + w
r.Bottom = y + hi
Scrl = 0
sy = 1
sm = 0
ly = 17
itmn = 0
Clear
End Sub

Public Sub Destroy()
h = 0
End Sub

Public Sub Add(Optional ByVal Key As String, Optional ByVal Text As String, Optional ByVal Image As Long, Optional ByVal Color As Long, Optional ByVal Enabled As Boolean = True, Optional ByVal Tabs As Long)
itmc = itmc + 1
ReDim Preserve itms(1 To itmc)
With itms(itmc)
 .Key = Key
 .Text = Text
 .i = Image
 .clr = Color
 .en = Enabled
 .x = Tabs
End With
Scrl = itmc * ItemHeight > r.Bottom - r.Top
If Scrl Then
 lC = (r.Bottom - r.Top) \ ItemHeight
 sm = itmc - lC
 lh = ((r.Bottom - r.Top - 34) * lC) \ (itmc - 1)
End If
End Sub

Public Sub Clear()
Erase itms
itmc = 0
End Sub

Public Sub SetImageList(pic As StdPicture, ByVal w As Long, ByVal hi As Long)
Imlw = w
Imlh = hi
bmpIml.CreateFromPicture pic
End Sub

Public Sub MouseDown(ByVal Button As Integer, ByVal x As Long, ByVal y As Long)
Dim i As Long
If Not en Then Exit Sub
If h <> 0 Then
 If Scrl And x + 17 > r.Right And y < r.Right Then
  If y > r.Top And y < r.Top + 17 And sy > 1 Then
   sy = sy - 1
   CalcL
   mz = 1
  End If
  If y > r.Top + 17 And y < r.Top + ly Then
   sy = sy - lC
   If sy < 1 Then sy = 1
   CalcL
   mz = 2
  End If
  If y > r.Top + ly And y < r.Top + ly + lh Then
   oy = ly - y
   mz = 3
  End If
  If y > r.Top + ly + lh And y < r.Bottom - 17 Then
   sy = sy + lC
   If sy > sm Then sy = sm
   CalcL
   mz = 4
  End If
  If y > r.Bottom - 17 And y < r.Bottom And sy < sm Then
   sy = sy + 1
   CalcL
   mz = 5
  End If
 ElseIf x > r.Left And x < r.Right And y > r.Top And y < r.Bottom Then
  i = sy + (y - r.Top) \ ItemHeight
  If i >= 1 And i <= itmc Then _
  If itms(i).en Then itmn = i
 End If
End If
End Sub

Public Sub MouseMove(ByVal Button As Integer, ByVal x As Long, ByVal y As Long)
If Not en Then Exit Sub
If h <> 0 Then
 mx = x
 my = y
 Select Case mz
 Case 1
  If sy > 1 Then sy = sy - 1
  CalcL
 Case 2
  sy = sy - lC
  If sy < 1 Then sy = 1
  CalcL
 Case 3
  ly = oy + y
  If ly < 17 Then ly = 17
  If ly > r.Bottom - r.Top - lh - 17 Then _
  ly = r.Bottom - r.Top - lh - 17
  sy = 1 + ((ly - 17) * (itmc - 1)) \ (r.Bottom - r.Top - 34)
 Case 4
  sy = sy + lC
  If sy > sm Then sy = sm
  CalcL
 Case 5
  If sy < sm Then sy = sy + 1
  CalcL
 End Select
End If
End Sub

Public Sub MouseUp(ByVal Button As Integer, ByVal x As Long, ByVal y As Long)
If Not en Then Exit Sub
If h <> 0 Then
 mz = 0
 CalcL
End If
End Sub

Public Sub MouseWheel(ByVal n As Long)
If en And h <> 0 Then
 sy = sy + n * 3 'damage x3 :-)
 If sy < 1 Then sy = 1
 If sy > sm And sm > 0 Then sy = sm
 'pDelta n
 CalcL
End If
End Sub

Public Property Get ListCount() As Long
ListCount = itmc
End Property

Public Property Get ListIndex() As Long
ListIndex = itmn - 1
End Property

Public Property Let ListIndex(n As Long)
itmn = n + 1
If itmn >= sy And itmn < sy + lC Then 'nothing
'ElseIf itmn > sm Then '??
' If sm > 0 Then
'  sy = sm
'  CalcL
' End If
ElseIf itmn < sy Then
 sy = itmn
Else 'error??
 sy = itmn - lC + 1
End If
If sy > sm And sm > 0 Then sy = sm
CalcL
End Property

Public Property Get List(ByVal index As Long) As String
List = itms(index + 1).Text
End Property

Public Property Get Key(ByVal index As Long) As String
On Error Resume Next
Key = itms(index + 1).Key
End Property

Private Sub DrawBon(ByVal x As Long, ByVal y As Long, ByVal hi As Long, ByVal n As Long)
StretchBlt h, x, y, 17, hi, bmpData.hdc, 32, 0, 17, 17, vbSrcCopy
bmpData.PaintPicture h, x + 1, y, 15, 3, 17, n * 22
StretchBlt h, x + 1, y + 3, 15, hi - 6, bmpData.hdc, 17, n * 22 + 3, 15, 16, vbSrcCopy
bmpData.PaintPicture h, x + 1, y + hi - 3, 15, 3, 17, n * 22 + 19
If hi > 14 Then bmpData.PaintPicture h, x + 5, y + hi \ 2 - 4, 7, 8, 32, 34 + n * 8
End Sub

Private Sub CalcL()
On Error Resume Next
ly = 17 + ((r.Bottom - r.Top - 34) * (sy - 1)) \ (itmc - 1)
End Sub

Public Property Get Enable() As Boolean
Enable = en
End Property

Public Property Let Enable(ByVal b As Boolean)
en = b
End Property
